home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Lib / tk-init.stk < prev    next >
Encoding:
Text File  |  1996-07-21  |  7.3 KB  |  234 lines
  1. ;;;;
  2. ;;;; Initialization file for STk
  3. ;;;;
  4. ;;;; This script is executed for each STk-based application. It arranges class 
  5. ;;;; bindings for widgets.
  6. ;;;;
  7. ;;;; Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  8. ;;;; 
  9. ;;;; Permission to use, copy, and/or distribute this software and its
  10. ;;;; documentation for any purpose and without fee is hereby granted, provided
  11. ;;;; that both the above copyright notice and this permission notice appear in
  12. ;;;; all copies and derived works.  Fees for distribution or use of this
  13. ;;;; software or derived works may only be charged with express written
  14. ;;;; permission of the copyright holder.  
  15. ;;;; This software is provided ``as is'' without express or implied warranty.
  16. ;;;;
  17. ;;;; This software is a derivative work of other copyrighted softwares; the
  18. ;;;; copyright notices of these softwares are placed in the file COPYRIGHTS
  19. ;;;;
  20. ;;;;           Author: Erick Gallesio [eg@unice.fr]
  21. ;;;;    Creation date: 17-May-1993 12:35
  22. ;;;; Last file update: 21-Jul-1996 15:51
  23. ;;;;
  24.  
  25. (unless (equal? *tk-version* "4.1")
  26.   (error "wrong version of Tk loaded: need 4.1 (this version is ~A)" 
  27.      *tk-version*))
  28.  
  29. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  30. ;;;;
  31. ;;;; Utilities
  32. ;;;;
  33. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  34. (define-macro (tk-get w option)
  35.   `(,w 'cget ,option))
  36.  
  37. (define-macro (tk-set! w option . value)
  38.   `(,w 'configure ,option ,@value))
  39.  
  40. (define (Tk-screen-changed  screen)
  41.   ;; This function is called when the screen is changed. Since I own only 
  42.   ;; one screen, I don't know what I must do here.
  43.   screen)
  44.  
  45. (define-macro (define-binding class event args . body)
  46.   (if (null? body)
  47.       `(bind ,class ,event "")
  48.       `(bind ,class ,event (lambda ,args ,@body))))
  49.  
  50. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  51.  
  52. ;; Turn off strict Motif look and feel as a default.
  53. (define *tk-strict-Motif*   #f)
  54.  
  55. ;; Following vars are used everywhere. So define them here
  56. (define tk::window       #f)
  57. (define tk::button-window  '())
  58. (define tk::relief       "sunken")
  59. (define tk::select-mode       "")
  60. (define tk::mouse-moved    #f)
  61. (define tk::press-x        0)
  62. (define tk::press-y        0)
  63. (define tk::x           0)
  64. (define tk::y           0)
  65. (define tk::after-id       "")
  66. (define tk::active-bg       "")
  67. (define tk::active-fg       "")
  68. (define tk::dragging       #f)
  69.  
  70.  
  71. (define tk::buttons     0)
  72. (define tk::focus     '())
  73. (define tk::grab     "")
  74. (define tk::inMenuButton '())
  75. (define tk::posted     #f)
  76. (define tk::selectMode     '())
  77. (define tk::cursor     "")
  78. (define tk::kill-buffer  "") ;; One kill buffer shared between all texts. 
  79.  
  80.  
  81. ;; add-binding --
  82. ;; This procedure adds a binding to a widget. It replaces the Tcl "+" mechanism
  83. ;; which is meaningless with closures. Furthermore, this mechanism permits
  84. ;; to add the binding BEFORE the old binding
  85. ;;
  86. (define (add-binding widget event binding before?)
  87.   (let ((old (bind widget event)))
  88.     (if (null? old)
  89.     (bind widget event binding)
  90.     ;;; We must find the parameters of the old and given bindings
  91.     ;;; The new binding is a new closure with the union of these 
  92.     ;;; parameters.
  93.     ;;; if:
  94.     ;;;   old binding is   (lambda (x y) ....)
  95.     ;;;   given binding is (lambda (x t a) ...)
  96.     ;;; We must construct the binding of the form
  97.     ;;;    (lambda (x y t a)
  98.     ;;;       ((lambda (x y) ....) x y)
  99.     ;;;       ((lambda (x t a) ....) x t a))
  100.     (let ((body-old (procedure-body (car old)))
  101.           (body-new (procedure-body binding)))
  102.       (if (and body-old body-new)
  103.           (let ((p-old (cadr body-old))
  104.             (p-new (cadr body-new)))
  105.         (bind widget
  106.               event 
  107.               (if before?
  108.               (eval `(lambda ,(set-union p-old p-new)
  109.                    (,binding ,@(cadr body-new))
  110.                    ,old))
  111.               (eval `(lambda ,(set-union p-old p-new)
  112.                    ,old
  113.                    (,binding ,@(cadr body-new)))))))
  114.           ;; 
  115.           (Error "add-binding: Incorrect binding ~S" binding))))))
  116.  
  117. ;; Tk:cancel-repeat --
  118. ;; This procedure is invoked to cancel an auto-repeat action described
  119. ;; by tk::after-id.  It's used by several widgets to auto-scroll
  120. ;; the widget when the mouse is dragged out of the widget with a
  121. ;; button pressed.
  122.  
  123. (define (Tk:cancel-repeat)
  124.   (after 'cancel tk::after-id)
  125.   (set! tk::after-id ""))
  126.  
  127. ;;;;
  128. ;;;; A procedure to forbid remote executution via the send Tk command
  129. ;;;;
  130. (define (inhibit-send)
  131.   ;; Redefine send sommand
  132.   (set! send @undefined)
  133.   ;; Issue a GC so that command is effectively deleted from Tk tables NOW
  134.   (gc))
  135.  
  136.  
  137. ;;;;
  138. ;;;; Define widget which require a lot of initialization as a kind of autoload
  139. ;;;; This allows a faster loading for small programs which use only a few widgets
  140. ;;;; and decreases memory usage
  141. ;;;; 
  142.  
  143. (define-macro (%redefine-Tk-command widget file)
  144.   `(set! ,widget
  145.      (let ((tk-cmd ,widget))
  146.        (lambda l
  147.          (let ((old ,widget))
  148.            (load ,(string-append *STk-library* "/STk/" file ".stk"))
  149.            (when (closure? old)
  150.          ;; We test here that old value is a true closure because when
  151.          ;; using STklos some Tk commands are already defined as generic.
  152.          ;; Reloading the file and setting widget and Tk:widget breaks
  153.          ;; the generic function. Weak but it seems to work
  154.          (set! ,widget tk-cmd)
  155.          (set! ,(string->symbol (format #f "tk:~a" widget)) tk-cmd))
  156.            (apply tk-cmd l))))))
  157.  
  158. (%redefine-Tk-command button        "button")
  159. (%redefine-Tk-command checkbutton    "button")
  160. (%redefine-Tk-command radiobutton    "button")
  161. (%redefine-Tk-command entry        "entry")
  162. (%redefine-Tk-command focus        "focus")
  163. (%redefine-Tk-command listbox        "listbox")
  164. (%redefine-Tk-command menu        "menu")
  165. (%redefine-Tk-command menubutton    "menu")
  166. (%redefine-Tk-command scale        "scale")
  167. (%redefine-Tk-command scrollbar        "scrollbar")
  168. (%redefine-Tk-command text        "text")
  169.  
  170. ;;
  171. ;; Make synonyms for all Tk-commands to "protect" them against redefinition
  172. ;;
  173. (define Tk:button    button)
  174. (define Tk:checkbutton    checkbutton)
  175. (define Tk:canvas    canvas)
  176. (define Tk:entry    entry)
  177. (define Tk:frame    frame)
  178. (define Tk:image    image)
  179. (define Tk:label     label)
  180. (define Tk:listbox    listbox)
  181. (define Tk:menu        menu)
  182. (define Tk:menubutton    menubutton)
  183. (define Tk:message    message)
  184. (define Tk:scale    scale)
  185. (define Tk:scrollbar    scrollbar)
  186. (define Tk:radiobutton    radiobutton)
  187. (define Tk:text        text)
  188. (define Tk:toplevel    toplevel)
  189.  
  190. (define Tk:after    after)
  191. (define Tk:bind        bind)
  192. (define Tk:bindtags    bindtags)
  193. (define Tk:bell        bell)
  194. (define Tk:clipboard    clipboard)
  195. (define Tk:destroy    destroy)
  196. (define Tk:focus    focus)
  197. (define Tk:grab        grab)
  198. (define Tk:lower    lower)
  199. (define Tk:option    option)
  200. (define Tk:pack        pack)
  201. (define Tk:place    place)
  202. (define Tk:raise    raise)
  203. (define Tk:selection    selection)
  204. (define Tk:tk        tk)
  205. (define Tk:tkwait    tkwait)
  206. (define Tk:update    update)
  207. (define Tk:winfo    winfo)
  208. (define Tk:wm        wm)
  209.  
  210. ;;;;
  211. ;;;; Some autoloads
  212. ;;;; 
  213. (autoload "palette"   Tk:set-palette! Tk:bisque)
  214. (autoload "dialog"    STk:make-dialog STk:center-window)
  215. (autoload "listener"  listener)
  216. (autoload "help"      help STk:show-help-file)
  217. (autoload "menu"      Tk:option-menu)
  218. (autoload "fileevent" Tk:fileevent fileevent) ; for backward compatibility
  219. ;;;;
  220. ;;;; report-error as a kind of autoload (must be a closure, rather than an 
  221. ;;;; autoload since C error function tests explicitely it is a closure before
  222. ;;;; applying its arguments
  223. ;;;;
  224. (autoload "error" STk:report-error bgerror *error-info* *error-code*)
  225. (autoload "sterm" sterm)
  226.  
  227. (define (report-error . args)
  228.   (apply STk:report-error args))
  229.  
  230. ;;;;
  231. ;;;; Retain now that Tk is fully initialized
  232. ;;;;
  233. (set! Tk:initialized? #t)
  234.